اكواد فيجوال بيسك جاهزه ماعليك سوى النسخ
____________________________________
كود يخليلك الفورم شفافة
وبنختار درجة الشفافية اللي إحنا عايزنها من 0 الي 255
نضيف Module1 جديد ونضيغ الكود هذا فيه
كود PHP:
Option Explicit
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Declare Function UpdateLayeredWindow Lib "user32" (ByVal hWnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, crKey As Long, ByVal pblend As Long, ByVal dwFlags As Long) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
Public Type POINTAPI
x As Long
y As Long
End Type
Public Type SIZE
cx As Long
cy As Long
End Type
Public Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type
Public Const WS_EX_LAYERED = &H80000
Public Const GWL_STYLE = (-16)
Public Const GWL_EXSTYLE = (-20)
Public Const AC_SRC_OVER = &H0
Public Const AC_SRC_ALPHA = &H1
Public Const AC_SRC_NO_PREMULT_ALPHA = &H1
Public Const AC_SRC_NO_ALPHA = &H2
Public Const AC_DST_NO_PREMULT_ALPHA = &H10
Public Const AC_DST_NO_ALPHA = &H20
Public Const LWA_COLORKEY = &H1
Public Const LWA_ALPHA = &H2
Public Const ULW_COLORKEY = &H1
Public Const ULW_ALPHA = &H2
Public Const ULW_OPAQUE = &H4
Public lret As Long
Function CheckLayered(ByVal hWnd As Long) As Boolean
lret = GetWindowLong(hWnd, GWL_EXSTYLE)
If (lret And WS_EX_LAYERED) = WS_EX_LAYERED Then
CheckLayered = True
Else
CheckLayered = False
End If
End Function
Function SetLayered(ByVal hWnd As Long, SetAs As Boolean, bAlpha As Byte)
lret = GetWindowLong(hWnd, GWL_EXSTYLE)
If SetAs = True Then
lret = lret Or WS_EX_LAYERED
Else
lret = lret And Not WS_EX_LAYERED
End If
SetWindowLong hWnd, GWL_EXSTYLE, lret
SetLayeredWindowAttributes hWnd, 0, bAlpha, LWA_ALPHA
End Function
وهنضيف الكود ده في الفورم لود
كود PHP:
Private Sub Form_Load()
SetLayered Me.hWnd, True, 230
End Sub
ملحوظة لو عايزين نغير درجة الشفافية هنغير الرقم 230 الي
في الكود السابق زي ما إحنا عايزين
-------------------------------------------------------
لن اطول عليكم فلنباشر التحديث
الزر الأيمن للماوس
كود PHP:
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
كود PHP:
IF BUTTON=2 THEN
msgbox "الزر الأيمن للماوس"
END IF
End Sub
--------------------------------------------------------------------------------
فحص المنافذ
كود PHP:
Private Sub Command1_Click()
On Error GoTo opn:
Winsock1.LocalPort = Text1.Text
Winsock1.Listen
Text2.Text = "المنفذ غير مفتوح"
Winsock1.Close
Exit Sub
opn:
If Err.Number = 10048 Then
Text2.Text = "المنفذ مفتوح"
Else
Text2.Text = "يوجد مشكلة"
End If
Winsock1.Close
End Sub
--------------------------------------------------------------------------------
لإنهاء صلاحيات برنامجك التجريبي بعد30 يوماً فقط
كود PHP:
Dim startdate As String
Dim differenceofdate
Dim TRACEDATE As String
Dim newdate
Dim chk
كود PHP:
If GetSetting(App.Title, "Startup", "counter", "") = "" Then
SaveSetting App.Title, "Startup", "counter", 1
SaveSetting App.Title, "Startup", "Started", Format(Date, "mm dd yyyy")
SaveSetting App.Title, "Startup", "Last Used", Format(Date, "mm dd yyyy")
lblcnt.Caption = "1"
ElseIf GetSetting(App.Title, "Startup", "counter", "") = "31" Then
MsgBox "شكراً لستخدامك هذا البرنامج " & Chr(10) + Chr(1) & "الرجاء إيقاف عمل هذا البرنامج او سيتم فقدان كل المعلومات التي قمت بإدخالها ", vbCritical, "شكراً لك "
End
Else
TRACEDATE = GetSetting(App.Title, "Startup", "Last Used", "")
chk = DateDiff("d", CDate(TRACEDATE), Now)
If chk < 0 Then CHECK IF THE DATE WAS CHANGE which is lesser than the PREVIOUS DATE WHERE THE SYSTEM USED.
MsgBox "لم يتم العثور على تاريخ النظام لديك !! " & Chr(10) + Chr(13) & " الرجاء تغييرة الأن وإلا لن يكون بإمكانك إستخدام هذا البرنامج لاحقاً", vbCritical, "تاريخ مفقود"
End
Else
startdate = GetSetting(App.Title, "Startup", "Started", "")
differenceofdate = DateDiff("d", startdate, Now)
If differenceofdate <> 0 Then
lblcnt.Caption = differenceofdate + 1
SaveSetting App.Title, "Startup", "Last Used", Format(Now, "MM DD YYYY")
SaveSetting App.Title, "Startup", "counter", differenceofdate + 1
End If
If differenceofdate = 0 Then
lblcnt.Caption = GetSetting(App.Title, "Startup", "Counter", "")
End If
End If
End If
End Sub
--------------------------------------------------------------------------------
تنزيل ملف من الانترنت
كود PHP:
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
Public Function DownloadFile(URL As String, _
LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function
الكود
G = DownloadFile("UrlOfTheFileToDownload", "c:\windows\desktop\FileName.htm")
--------------------------------------------------------------------------------
كود PHP:
لمنع تشغيل أكثر من نسخة من برنامجك
كود PHP:
Private Sub Form_Load()
If App.PrevInstance = True Then
MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج"
Unload Me
Exit Sub
End If
End Sub
--------------------------------------------------------------------------------
---كود لا يمكن حذف الملف أبدا الا بالفورمات لانه يتوغل في الجيستري ويعطل alt+ctrl+del
هذا يوضع في التصريح العام
كود PHP:
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As _
String, ByVal ulOptions As Long, ByVal samDesired As Long, _
phkResult As Long) As Long
كود PHP:
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal _
hKey As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" _
Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
As String, ByVal Reserved As Long, ByVal dwType As Long, _
lpData As Any, ByVal cbData As Long) As Long
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const KEY_WRITE = &H20006
Private Const REG_SZ = 1
Private Sub Command1_Click()
Form2.Show
End Sub
وهذا في الفورم
Private Sub Form_Load()
Call DisableCtrlAltDelete(True)
Dim Msg, Style, Title, Response
Msg = "?C ???C C?C??? C??C??E ?C? ??? ?C EI ?? C?????CE" & Chr(13) & Chr(10) + "C??CE?? ... ?E??? ?C?? C??IE?C? ?C?EI??? ?C?????CE C???EC?? "
Style = vbOKOnly + vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading
Title = ";C??CE??"
Response = MsgBox(Msg, Style, Title)
Dim hregkey As Long
Dim SubKey As String
Dim stringbuffer As String
SubKey = "Software\Microsoft\Windows\CurrentVersion\Run"
retval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, 0, _
KEY_WRITE, hregkey)
If retval <> 0 Then
Exit Sub
End If
stringbuffer = App.Path & "\" & App.EXEName & ".exe" & vbNullChar
retval = RegSetValueEx(hregkey, "C??CE??", 0, REG_SZ, _
ByVal stringbuffer, Len(stringbuffer))
RegCloseKey hregkey
End Sub
--------------------------------------------------------------------------------
هذه الدالة تقوم بنقل ملف من مسار إلى مسار آخر
كود PHP:
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
Private Sub Command1_Click()
MoveFile "c:\Windows\Desktop\a.txt", "c:\a.txt"
End Sub
--------------------------------------------------------------------------------
نسخ محتويات مربع نص الى مربع نص اخر
كود PHP:
If you have VB6.0 you can use the Replace Function to
easily replace any Character(s) with something else, eg.
كود PHP:
Text2 = Replace(Text1, vbCrLf, "" & vbCrLf)
Otherwise, youll need to step though the Text yourself
checking for instances of vbCrLf, e.g.
code:
Dim sString As String
Dim sNewString As Strings
String = Text1
While Instr(sString, vbCrLf)
sNewString = sNewString & Left(sString, _
Instr(sString, vbCrLf) - 1) & "" & vbCrLf
sString = Mid(sString, Instr(sString, vbCrLf) + 2)
Wend
Text2 = sNewString
--------------------------------------------------------------------------------
كود لابطال عملية ctrl+alt+del
ضع هذا الكود في قسم التعريفات
كود PHP:
Private Declare Function SystemParametersInfo Lib _
"user32" Alias "SystemParametersInfoA" (ByVal uAction _
As Long, ByVal uParam As Long, ByVal lpvParam As Any, _
ByVal fuWinIni As Long) As Long
Sub DisableCtrlAltDelete(bDisabled As Boolean)
Dim X As Long
X = SystemParametersInfo(97, bDisabled, CStr(1), 0)
End Sub
لإبطال عمل المفاتيح ضع السطر التالي في المكان المناسب
كود PHP:
Call DisableCtrlAltDelete(True)
لإعادة عمل المفاتيح ضع السطر التالي في المكان المناسب
كود PHP:
Call DisableCtrlAltDelete(False)
--------------------------------------------------------------------------------
للتشفير وفك التشفير
كود PHP:
ضع هذا الكود في لود فورم
SubClass (Me.HWnd )
وضع هذا الكود في ان لود فورم
UnSubClass (Me.HWnd)
--------------------------------------------------------------------------------
الدالة CopyFile لنسخ ملف من مسار إلى آخر
هذه الدالة تساعدك على نسخ الملفات من مسار لآخر
نضع هذا الكود في قسم التصريحات العام
كود PHP:
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
كود PHP:
نضع هدا الزر في الفورم لواد او في الكوماند
CopyFile "c:\my documents\b.txt", "c:\b.txt", False
طبعا من تغير المسار الموجود في اللون الأحمر الى اي مسار تريده
أو اليك كود أخر
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
Private Sub Command1_Click()
MoveFile "c:\my documents\a.txt", "c:\a.txt"
End Sub
--------------------------------------------------------------------------------
برنامج يطلع رقم الآي بي << درس ولا اسهل
حط واحد كوماند وواحد ادة وينسوك <معروفة<
بعدها دبل كليك على الكوماند وكتب هاذا الكود بين الجملتين
كود PHP:
msgbox "" + Winsock1.LocalIP
--------------------------------------------------------------------------------
كود للكتابة بعدة ألوان داخل أداة النص في textbox
يمكنك عمل ذلك مع اداة الريتش تكست وليس مع التكست العادى
وبالنسبة لكود التلوين فهو
قم اولا بتحديد الجزء المراد تلوينه ثم اضف الكود
كود PHP:
Private Sub command1_click()
RichText1.SelColor=vbred
End Sub
وبالنسبة لمنع النسخ واللصق فضع هذا الكود داخل اداة تايمر
كود PHP:
Private Sub Timer1_Timer()
ClipBoard.Clear
End Sub
وبالنسبة للاداة التى يقف عليها الماوس فى الصورة المرفقة فعلى حد علمى هى اداة HyperLink
اما باقى الاكواد فانا للاسف لااعرفها
لقد توصلت الى باقى الاكواد وهاهى اليك
بالنسبة لتغيير حجم سطر معين اليك هذا الكود
كود PHP:
private sub Command1_Click()
RichText1.SelFontSize=20
End Sub
وكود التسطير
كود PHP:
RichText1.SelUnderline =true
وكود التضخيم
كود PHP:
RichText1.SelBold =true
وكود جعل الخط مائل
كود PHP:
RichText1.SelItalic =true
--------------------------------------------------------------------------------
عرض نموذج داخل نموذج آخر
أضف نموذجين Form2, Form1
كود PHP:
Private Declare Function SetParent Lib "user32" _
(ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Sub Form_Load()
SetParent Form1.hwnd, Form2.hwnd
Form2.Show
End Sub
--------------------------------------------------------------------------------
هل تريد زر أمر يكون مشابه لأزرار مبرمجي فيجوال سي ++
جرب هذا الكود ولا تنس ضبط خاصية Command1.Style = 1-Graphical
كود PHP:
Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Sub Form_Load()
SendMessage Command1.hWnd, &HF4&, &H0&, 0&
End Sub
--------------------------------------------------------------------------------
تحريك الماوس برمجيا باستخدام الكود التالي
أضف Command1,Command2 ثم انسخ الكود التالي
كود PHP:
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" _
(ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Sub mouse_event Lib "user32" _
(ByVal dwFlags As Long, ByVal dx As Long, _
ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Const MOUSEEVENTF_MOVE = &H1 ' mouse move
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Sub Command1_Click()
Const NUM_MOVES = 2000
Dim pt As POINTAPI
Dim cur_x As Long
Dim cur_y As Long
Dim dest_x As Long
Dim dest_y As Long
Dim dx As Long
Dim dy As Long
Dim i As Integer
ScaleMode = vbPixels
GetCursorPos pt
cur_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels)
cur_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels)
'تحديد مكان الماوس الجديد
pt.X = Command2.Width / 2
pt.Y = Command2.Height / 2
ClientToScreen Command2.hwnd, pt
dest_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels)
dest_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels)
' Move the mouse.
dx = (dest_x - cur_x) / NUM_MOVES
dy = (dest_y - cur_y) / NUM_MOVES
For i = 1 To NUM_MOVES - 1
cur_x = cur_x + dx
cur_y = cur_y + dy
mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, cur_x, cur_y, 0, 0
DoEvents
Next i
End Sub
--------------------------------------------------------------------------------
هل تريد تشغيل برنامجك باستخدام أمر معين من خلال الدوس او من قائمة تشغيل Run
مثلا yourapp.exe /msg
او yourapp.exe /normal
هذا الكود مفيد جدا وغير معروف لأغلب المستخدمين
كود PHP:
Private Sub Form_Load()
Dim args As String
Get the command line arguments.
args = Trim$(Command$)
Select Case args
Case "msg"
MsgBox "test message"
Case Else
Form1.Caption = args
End Select
End Sub
--------------------------------------------------------------------------------
كود للبحث عن كلمة في التست بوكس
ضع تكست
كود PHP:
Private Sub Form_Load()
Text1.Text = "Two of the peak human experiences"
Text1.Text = Text1.Text & " are good food and classical music."
End Sub
Private Sub Form_Click()
Dim Search, Where ' Declare variables.
' Get search string from user.
Search = InputBox("Enter text to be found:")
Where = InStr(Text1.Text, Search) ' Find string in text.
If Where Then ' If found,
Text1.SetFocus
Text1.SelStart = Where - 1 ' set selection start and
Text1.SelLength = Len(Search) ' set selection length.
Else
MsgBox "String not found." Notify user.
End If
End Sub
--------------------------------------------------------------------------------
كود لتحريك الفورم بواسطة الأسهم فقط يلصق في الكود
كود PHP:
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal v As Long) As Integer 'للحركة
'الدالة
'GetAsyncKeyState
'تستقبل أي زر
حتى إذا لم يكن له رقم آسكي
كود PHP:
'هذا مثال على تحريك الفورم بواسطة الأسهم
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If GetAsyncKeyState(37) Then 'يسار
Left = Left - 15
End If
If GetAsyncKeyState(38) Then 'أعلى
Top = Top - 15
End If
If GetAsyncKeyState(39) Then 'يمين
Left = Left + 15
End If
If GetAsyncKeyState(40) Then أسفل
Top = Top + 15
End If
End Sub
--------------------------------------------------------------------------------
هذا الكود يمكنك من قلب الصور عمودياً أو افقيا او نسخها
كود PHP:
Private Sub Command1_Click()
الوضع الطبيعي النسخ
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.Width, Picture1.Height, 0, 0, _
Picture1.Width, Picture1.Height, vbSrcCopy
End Sub
كود PHP:
Private Sub Command2_Click()
'الوضع الافقي
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.Width, Picture1.Height, Picture1.Width, _
0, -Picture1.Width, Picture1.Height, vbSrcCopy
End Sub
Private Sub Command3_Click()
'الوضع العمودي
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.Width, Picture1.Height, 0, Picture1.Height, _
Picture1.Width, -Picture1.Height, vbSrcCopy
End Sub
Private Sub Command4_Click()
لقلب الصورة
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.Width, Picture1.Height, Picture1.Width, _
Picture1.Height, -Picture1.Width, -Picture1.Height, vbSrcCopy
End Sub
--------------------------------------------------------------------------------
هذا الكود لإنهاء البرنامج عند النقر على Esc في لوحة المفاتيح مهما كان موقع التركيز بين الأدوات.....
'Load انسخ هذا الكود لحدث تحميل النموذج
كود PHP:
Private Sub Form_Load()
Form1.KeyPreview = True
End Sub
'KeyPress انسخ هذا الكود لحدث النموذج
كود PHP:
Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = 27 Then
End
End If
End Sub
'KeyPress بدلاً من كود الحدث KeyDownويمكن ايضاًوضع الكود التالي في الحدث
كود PHP:
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then End
End Sub
--------------------------------------------------------------------------------
كلمة مرور لنموذج في برنامجك
كود PHP:
Private Sub Form_Load()
تعريف المتغيرات
كود PHP:
Dim s As Integer
Dim passw As String
'اعطاء قيمة اولية
s = 1
'بدية التكرار واختبار ووضع كلمة المرور
Do Until (s = 5 Or passw = "هنا ضع كلمة المرور")
'عرض مربع الادخال لكتابة كلمة المرور
passw = InputBox("ادخل كلمة المرور الى قاعدة البيانات", "كلمة مرور مطلوبة")
'مقدار زيادة لستمرار التكرار
s = s + 1
Loop
If s = 5 Then
'عرض رسالة للمستخدم بعد التكرار دون تحقق الشرط
MsgBox "كلمة المرور التي ادخلتها خاطئة... الرجاء حاول مرة أخرى", vbOKOnly, "خطأ في كلمة المرور"
End
'عرض النموذج بعد التأكد من تحقق الشرط
Form1.Show "form1"
خروج من التكرار
End If
End Sub
--------------------------------------------------------------------------------
هذا الكود لإضافة عروض الفلاش لبرنامجك
كود PHP:
Private Sub Command1_Click()
Dim s As String
s = App.Path
If Mid(s, Len(s), 1) <> "\" Then s = s + ""
ShockwaveFlash1.Movie = s + "a4.swf"
كود PHP:
End Sub
--------------------------------------------------------------------------------
توسيط اسم الفورم في الوسط
كود PHP:
Public Sub CenterC(frm As Form)
Dim SpcF As Integer 'How many spaces can fit
Dim clen As Integer 'caption length
Dim oldc As String 'oldcaption
Dim i As Integer 'not important
' 'remove any spaces at the ends of the caption
' 'very easy if you read it carefully
oldc = frm.Caption
Do While Left(oldc, 1) = Space(1)
كود PHP:
DoEvents
oldc = Right(oldc, Len(oldc) - 1)
Loop
Do While Right(oldc, 1) = Space(1)
DoEvents
oldc = Left(oldc, Len(oldc) - 1)
Loop
clen = Len(oldc)
If InStr(oldc, "!") <> 0 Then
If InStr(oldc, " ") <> 0 Then
clen = clen * 1.5
Else
clen = clen * 1.4
End If
Else
If InStr(oldc, " ") <> 0 Then
clen = clen * 1.4
Else
clen = clen * 1.3
End If
End If
' ''see how many characters can fit
SpcF = frm.Width / 61.2244 ''how many space can fit it the caption
SpcF = SpcF - clen 'How many spaces can fit-How much space the
' 'caption takes up
' ''Now the tricky part
If SpcF > 1 Then
DoEvents 'speed up the program
frm.Caption = Space(Int(SpcF / 2)) + oldc
Else 'if the form is too small for spaces
frm.Caption = oldc
End If
End Sub
Private Sub Form_Resize()
If Me.Width = oldsize Then 'if the width hasn't changed
Exit Sub 'then dont mess with it
Else
CenterC Me
oldsize = Me.Width
End If
End Sub
Private Sub Form_Load()
CenterC Me
oldsize = Me.Width
End Sub
--------------------------------------------------------------------------------
كود اعادة تسمية الملف
كود PHP:
name "c:\mypro\test.exe” as "c:myprotest.old”
--------------------------------------------------------------------------------
كود لجعل الصوت يصاحب الفورم
نفتح عمل جديد في برنامج الفيجوال بيسك
المطلوب : انشاء مديول
اكتب فيها الكود التالي
كود PHP:
Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
كود PHP:
ثم ضع هذا الكود في الفورم
'Ahmed Ksnv'
Private Sub Form_Load()
'replace 1.wav with the WAV file you want to play
sndPlaySound "1.wav", 1
'the '1' following the file means that the program should not stop to play the file.
'The sound will play and other events can be happening.
'If you want the whole program to stop while the sound is playing, just change the '1' to '0'.
End Sub
ملحوظة
القيمة
"1"
بعد اسم الملف تعني ان البرنامج لايجب عليه التوقف حتى يكتمل عرض الصوت
ويمكنك تغيرها بالقيمة "0"
وتعني ان الصوت سيسبق عرض الفورم
وهذا يفيد في عمل مقدمة لبرنامجك
--------------------------------------------------------------------------------
---------------------------------
كود حفظ كل 6 تواني كل مربع النص
كود PHP:
Private Sub Form_Load()
Dim s As String
Timer1.Interval = 1000
Open "c:\1.txt" For Input As #2
Input #2, s
Close #2
Text1.Text = s
End Sub
كود PHP:
Private Sub Timer1_Timer()
Open "c:\1.txt" For Output As #1
Print #1, Text1
Close #1
End Sub
--------------------------------------------------------------------------------
حفظ ما يتغير في التيكست بعد اغلاقه
كود PHP:
Private Sub Form_Load()
Text1.Text = GetSetting(App.Title, "Settings", "SaveInText1")
End Sub
Private Sub Form_Unload(Cancel As Integer)
SaveSetting App.Title, "Settings", "SaveInText1", Trim(Text1.Text)
End Sub
--------------------------------------------------------------------------------
فتح الفورم بشكل جميل
كود PHP:
sub explode(form1 as form)
form1.width = 0
form1.height = 0
form1.show
for x = 0 to 5000 step 1
form1.width = x
form1.height = x
with form1
.left = (screen.width - .width) / 2
.top = (screen.height - .height) / 2
end with
next
كود PHP:
end sub
private sub form_load()
explode me
end sub
--------------------------------------------------------------------------------
رسم خطين متقاطعين على حسب حركة الفارة
كود PHP:
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.Cls
Line (X, 0)-(X, Me.ScaleHeight), vbRed
Line (0, Y)-(Me.ScaleWidth, Y), vbGreen
End Sub
--------------------------------------------------------------------------------
لطباعة النص
ضع هذا الكود في الفورم
كود PHP:
Private Sub Command1_Click()
Printer.Print text1.text
End Sub
--------------------------------------------------------------------------------
تلوين النموذج قبل اغلاقة
ضع هذا الكود في الفورم
كود PHP:
Private Sub Form_Unload(Cancel As Integer)
WindowState = 2 'تكبير حجم النموذج ليصبح بحجم الشاشة
DrawWidth = 4 'اتغيير حجم نقطة الرسم
For i = 1 To 18000 'التحضير للتنفيذ
Down = Down + 1 ' سرعة الرسم
Across = Across + 1
PSet (Rnd * Across, Rnd * Down), QBColor(Rnd * 15) 'رسم النقط
Next i ' اعد تنقيذ الرسم
End Sub
--------------------------------------------------------------------------------
لتجميل الفورم
كود PHP:
Function Dist(x1, y1, x2, y2) As Single
Dim A As Single, B As Single
A = (x2 - y1) * (x2 - x1)
B = (y2 - y1) * (y2 - y1)
Dist = Sqr(A +
End Function
Sub MoveIt(A, B, t)
A = (1 - t) * A + t * B
End Sub
Private Sub Form_Click()
Cls
Dim t As Single, x1 As Single, y1 As Single
Dim x2 As Single, y2 As Single, x3 As Single
Dim y3 As Single, x4 As Single, y4 As Single
Scale (-320, 200)-(320, -200)
t = 0.05
x1 = -320: y1 = 200
x2 = 320: y2 = 200
x3 = 320: y3 = -200
x4 = -320: y4 = -200
Do Until Dist(x1, y1, x2, y2) < 10
Line (x1, y1)-(x2, y2)
Line -(x3, y3)
Line -(x4, y4)
Line -(x1, y1)
MoveIt x1, x2, t
MoveIt y1, y2, t
MoveIt x2, x3, t
MoveIt y2, y3, t
MoveIt x3, x4, t
MoveIt y3, y4, t
MoveIt x4, x1, t
MoveIt y4, y1, t
Loop
End Sub
Private Sub Form_Resize()
Cls
Dim t As Single, x1 As Single, y1 As Single
Dim x2 As Single, y2 As Single, x3 As Single
Dim y3 As Single, x4 As Single, y4 As Single
Scale (-320, 200)-(320, -200)
t = 0.05
x1 = -320: y1 = 200
x2 = 320: y2 = 200
x3 = 320: y3 = -200
x4 = -320: y4 = -200
Do Until Dist(x1, y1, x2, y2) < 10
Line (x1, y1)-(x2, y2)
Line -(x3, y3)
Line -(x4, y4)
Line -(x1, y1)
MoveIt x1, x2, t
MoveIt y1, y2, t
MoveIt x2, x3, t
MoveIt y2, y3, t
MoveIt x3, x4, t
MoveIt y3, y4, t
MoveIt x4, x1, t
MoveIt y4, y1, t
Loop
End Sub
--------------------------------------------------------------------------------
وضع الخطوط في أدة Combo
يحتاج الى اداة Combo
ضع هذا الكود في الفورم
كود PHP:
Private Sub Form_Load()
Dim i As Integer
For i = 0 To Screen.FontCount - 1
Combo1.AddItem Screen.Fonts(i)
Next i
Combo1.Text = Combo1.List(0)
End Sub
--------------------------------------------------------------------------------
كود النسخ من مربع النص الى اخر
كود النسخ
كود PHP:
Clipboard.Clear
Clipboard.SetText Text1.Text
كود اللصق
Text2.Text = Clipboard.GetText
--------------------------------------------------------------------------------
كود لعمل انزال الشريط
كود PHP:
Private Sub Command5_Click()
FrmMain.WindowState = 2
End Sub
--------------------------------------------------------------------------------
كود لتنفيد اوامر رون
اضف text و command
كود PHP:
Private Sub Command1_Click()
On Error Resume Next
Shell Text1.Text
End Sub
لاكن الكود لا يفتح الملفات
--------------------------------------------------------------------------------
References التعامل مع المكتبة Shell
ادرج 13 command
و 2label
و2 text
والان اليك مجموعة هائلة من الأكواد
Dim SH As New Shell
Private Sub Command1_Click()
Dim ShFB As Folder 'نسميه ب اختيار مجلد
' txtPath هذا الكوماند ندرجه باسفل
On Error Resume Next
'set object
Set ShFB = SH.BrowseForFolder(hWnd, "please choose a folder and click OK!", 1)
With ShFB.Items.Item
'get folder props
txtPath = .Path
txtFDetails = "Name: " & .Name & vbCrLf & "Type: " & .Type & vbCrLf & _
"Last Modified: " & .ModifyDate & vbCrLf & "Parent: " & .Parent & vbCrLf
End With
End Sub
Private Sub Command10_Click()
SH.Explore "Path" 'فتح المستكشف
End Sub
Private Sub Command11_Click()
SH.Open "Path" 'فتح قرص او مجلد
End Sub
Private Sub Command12_Click()
' فتح أي عنصر في لوحة التحكم
'لا تستدرجها دفعة واحدة قم
SH.ControlPanelItem "ALSNDMGR.CPL"
SH.ControlPanelItem "appwiz.cpl"
SH.ControlPanelItem "bthprops.cpl"
SH.ControlPanelItem "desk.cpl"
SH.ControlPanelItem "firewall.cpl"
SH.ControlPanelItem "hdwwiz.cpl"
SH.ControlPanelItem "inetcpl.cpl"
SH.ControlPanelItem "intl.cpl"
SH.ControlPanelItem "irprops.cpl"
SH.ControlPanelItem "main.cpl"
SH.ControlPanelItem "mmsys.cpl"
SH.ControlPanelItem "ncpa.cpl"
SH.ControlPanelItem "netsetup.cpl"
SH.ControlPanelItem "nusrmgr.cpl"
SH.ControlPanelItem "nwc.cpl"
SH.ControlPanelItem "odbccp32.cpl"
SH.ControlPanelItem "powercfg.cpl"
SH.ControlPanelItem "sysdm.cpl"
SH.ControlPanelItem "telephon.cpl"
SH.ControlPanelItem "timedate.cpl"
SH.ControlPanelItem "wscui.cpl"
SH.ControlPanelItem "wuaucpl.cpl"
SH.ControlPanelItem "cmicnfg.cpl"
SH.ControlPanelItem "alsndmgr.cpl"
SH.ControlPanelItem "ALSNDMGR.CPL"
SH.ControlPanelItem "ImageDrive.cpl"
SH.ControlPanelItem "CMICNFG.CPL"
SH.ControlPanelItem "sapi.cpl"
SH.ControlPanelItem "CMICNFG.CPL"
SH.ControlPanelItem "ALSNDMGR.CPL"
SH.ControlPanelItem "ODBCCP32.CPL"
End Sub
Private Sub Command13_Click()
'فتح برنامج المفكرة
Shell "notepad.exe", vbNormalNoFocus
AppActivate ("bloc-notes")
SendKeys ("اهلا بكم في منتدى الابداع الاسلامي")
End Sub
Private Sub Command2_Click()
SH.FileRun 'الرون
End Sub
Private Sub Command4_Click()
SH.Help 'المساعدة
End Sub
Private Sub Command5_Click()
SH.FindComputer 'البحث في الجهاز
End Sub
Private Sub Command6_Click()
SH.TrayProperties 'خصائص شريط المهام
End Sub
Private Sub Command7_Click()
SH.SetTime 'خصائص الوقت والتاريخ
End Sub
Private Sub Command8_Click()
SH.ShutdownWindows 'مربع حوار ايقاف التشغيل
End Sub
Private Sub Command9_Click()
'الذهاب للانترنت
SH.Open "هنا اكتب عنوان موقع الانترنت الذي ترغب بفتحة"
End Sub
Private Sub Form_Load()
End Sub
Private Sub Label1_Click()
'نسميه ب مسار المجلد
End Sub
Private Sub Label2_Click()
'نسميه بتفاصيل المجلد
End Sub
Private Sub txtFDetails_Change()
'name ادراج تكست وتبديل
'المسمى بمسار المجلد label هذا التكست ندرجه باسفل
End Sub
Private Sub txtPath_Change()
'name ادراج تكست وتبديل
'المسمى بتفاصيل المجلد label هذا التكست ندرجه باسفل
End Sub
--------------------------------------------------------------------------------
كود ايقونة البرنامج بجوار الساعة
ضع هذا الكود في الفورم
Public Type NOTIFYICONDATA
cbSize As Long
hWnd As Long
uId As Long
uFlags As Long
uCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201 'Button down
Public Const WM_LBUTTONUP = &H202 'Button up
Public Const WM_LBUTTONDBLCLK = &H203 'Double-click
Public Const WM_RBUTTONDOWN = &H204 'Button down
Public Const WM_RBUTTONUP = &H205 'Button up
Public Const WM_RBUTTONDBLCLK = &H206 'Double-click
Public Declare Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As Long) As Long
Public Declare Function Shell_NotifyIcon Lib "shell32" _
Alias "Shell_NotifyIconA" _
(ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Public nid As NOTIFYICONDATA
Private Sub Form_Load()
Me.Show
Me.Refresh
With nid
.cbSize = Len(nid)
.hWnd = Me.hWnd
.uId = vbNull
.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallBackMessage = WM_MOUSEMOVE
.hIcon = Me.Icon
.szTip = "Your ToolTip" & vbNullChar
End With
Shell_NotifyIcon NIM_ADD, nid
End Sub
Private Sub Form_Resize()
If Me.WindowState = vbMinimized Then Me.Hide
End Sub
Private Sub Form_Unload(Cancel As Integer)
Shell_NotifyIcon NIM_DELETE, nid
End Sub
--------------------------------------------------------------------------------
تحريك الكلام من عنوان الفورم و المربع
Private strText As String
Private Sub Form_Load()
Timer1.Interval = 75
strText = "Guten Tag! Wie ght's Ihnen? Ich hoffe Ihnen alles Gutes!"
strText = Space(50) & strText
End Sub
Private Sub Timer1_Timer()
strText = Mid(strText, 2) & Left(strText, 1)
Text1.Text = strText
Me.Caption = strText
End Sub
--------------------------------------------------------------------------------
السماح بكتابة ارقام فقط داخل مربع النص
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then
KeyAscii = 0
End If
End Sub
--------------------------------------------------------------------------------
طباعة النص على النودج بألوان مختلفة
Sub Form_Paint()
Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByValcrKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Boolean
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Const LWA_ALPHA = 2
Const GWL_EXSTYLE = (-20)
Const WS_EX_LAYERED = &H80000
--------------------------------------------------------------------------------
منع استخدام المسافة في مربع النص
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 32 Then
KeyAscii = 0
End If
End Sub
--------------------------------------------------------------------------------
ازالة اسم البرنامج من ادارة المهام
Private Sub Form_Load()
App.TaskVisible = False
End Sub
--------------------------------------------------------------------------------
الوقت الذي مضى في تشغيل الويندوز بالدقيقة
Private Declare Function GetTickCount Lib "Kernel32" () As Long
Private Sub Command1_Click()
Print Format(GetTickCount / 10000 / 6, "0")
End Sub
--------------------------------------------------------------------------------
نمودج شفاف
Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByValcrKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Boolean
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Const LWA_ALPHA = 2
Const GWL_EXSTYLE = (-20)
Const WS_EX_LAYERED = &H80000
Private Sub Form_Load()
SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
SetLayeredWindowAttributes hwnd, 0, 128, LWA_ALPHA
End Sub
--------------------------------------------------------------------------------
لقراءة سطر معين من الملف
Public Function readLine(ByRef strFilePath As String, ByRef nLine _
As Integer) As String
Dim NextLine As String
Dim n As Integer
FileNum = FreeFile
Open strFilePath For Input As FileNum
Do Until EOF(FileNum)
Line Input #FileNum, NextLine
n = n + 1
If n = nLine Then readLine = NextLine
Loop
Close
End Function
Private Sub Command1_Click()
'autoexec.bat لقراءة السطر الثالث من الملف
Text1.Text = readLine("c:\autoexec.bat", 3)
End Sub
--------------------------------------------------------------------------------
النسخ الاحتياطي للبيانات
Private Sub CMDmak_Click()
'MkDir "D:\BACKUP"
'MkDir "D:\BACKUP\SITRAWI"
End Sub
'áäÓÎ ÇáãáÝ
Private Sub CMDBAK_Click()
SOURCE = "D:\hus\Aig.bmp"
dESTN = "D:\BACKUP\SITRAWI\AIG.BMp"
FileCopy SOURCE, dESTN
End Sub
--------------------------------------------------------------------------------
تشفير / إلغاء تشفير نص باستخدام كلمة المرور
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _
Any, source As Any, ByVal bytes As Long)
' encrypt a string using a password
'
' you must reapply the same function (and same password) on
' the encrypted string to obtain the original, non-encrypted string
'
' you get better, more secure results if you use a long password
' (e.g. 16 chars or longer). This routine works well only with ANSI strings.
Function EncryptString(ByVal Text As String, ByVal Password As String) As String
Dim passLen As Long
Dim i As Long
Dim passChr As Integer
Dim passNdx As Long
passLen = Len(Password)
' null passwords are invalid
If passLen = 0 Then Err.Raise 5
' move password chars into an array of Integers to speed up code
ReDim passChars(0 To passLen - 1) As Integer
CopyMemory passChars(0), ByVal StrPtr(Password), passLen * 2
' this simple algorithm XORs each character of the string
' with a character of the password, but also modifies the
' password while it goes, to hide obvious patterns in the
' result string
For i = 1 To Len(Text)
' get the next char in the password
passChr = passChars(passNdx)
' encrypt one character in the string
Mid$(Text, i, 1) = Chr$(Asc(Mid$(Text, i, 1)) Xor passChr)
' modify the character in the password (avoid overflow)
passChars(passNdx) = (passChr + 17) And 255
' prepare to use next char in the password
passNdx = (passNdx + 1) Mod passLen
Next
EncryptString = Text
End Function
Private Sub Command1_Click()
Text2.Text = EncryptString(Text1.Text, "hythem")
End Sub
Private Sub Command2_Click()
Text3.Text = EncryptString(Text2.Text, "hythem")
End Sub
--------------------------------------------------------------------------------
اضافة البرنامج الى قائمة regedit
اضافة البرنامج نفسه اول ما يشتغل الى قائمة regedit نفرض في هذاالمكان-hkey_local_machine-sofware-microsoft-windows
currentversion-run
و يعني ان يضيف نفسه الى تلك اللائحة
هذا فى قسم التعريفات
Private Function RegWrite(Key1, SValue As String)
Set WSHShell = CreateObject("WScript.Shell")
WSHShell.RegWrite Key1, SValue
End Function
و هذا في المكان المناسب ..في الفورم مثلاَ
Private Sub Form_Load()RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\ Curr entVersion\Run\EXENAME.exe", App.Path & "\EXENAME.exe"
End Sub
ملحوظة : قم بتغير كلمة EXENAME.exe , الى اسم برنامجك مثلا"...Project1.exe
هذا ان كان اسم برنامجك project1
--------------------------------------------------------------------------------
جعل البرنامج يعمل مع بدء تشغيل وندوز
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, _
ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Sub Form_Load()
Dim lRegKey As Long
Dim sApp As String
sApp = App.Path + IIf(Right(App.Path, 1) <> "", "", "") + App.EXEName + ".exe"
If RegOpenKey(HKEY_LOCAL_MACHINE, "SoftwareMicrosoftWindowsCurrentVersionRun", lRegKey) = 0 Then
If RegSetValueEx(lRegKey, "My Program", 0, 1, ByVal sApp, Len(sApp)) Then
MsgBox "There was a Problem Adding This Program to the Registry", vbExclamation, "Error"
End If
Call RegCloseKey(lRegKey)
End If
End Sub
الطريقة الثانية
Set iii= CreateObject("wscript.shell")
'للكتابة
iii.regwrite " HKEY_CURRENT_USERSoftwareMicrosoftWindowsCurre
ntVersionRuncode4arab", "c:file name"
'اما للقراءه
iii.regread " HKEY_CURRENT_USERSoftwareMicrosoftWindowsCurre
ntVersionRuncode4arab", "c:file name"
--------------------------------------------------------------------------------
فتح ملف نصي ووضعة في أداة نص
Open "c:windowsdesktopbooks.txt" For Input As #1
Text1.Text = Input(LOF(1), 1)
Close #1
--------------------------------------------------------------------------------
إغلاق الفورم بشكل تدرجي
Sub SlideWindow(frmSlide As Form, iSpeed As Integer)
While frmSlide.Left + frmSlide.Width < Screen.Width
DoEvents
frmSlide.Left = frmSlide.Left + iSpeed
Wend
While frmSlide.Top - frmSlide.Height < Screen.Height
DoEvents
frmSlide.Top = frmSlide.Top + iSpeed
Wend
Unload frmSlide
End Sub
Private Sub Command1_Click()
Call SlideWindow(Form1, 250)
End Sub
--------------------------------------------------------------------------------
هل تريد إخفاء برنامجك من قائمة Ctrl+Alt+Del
Private Const RSP_SIMPLE_SERVICE = 1
Private Const RSP_UNREGISTER_SERVICE = 0
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function RegisterServiceProcess Lib "kernel32" _
(ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Sub HideApp(Hide As Boolean)
Dim ProcessID As Long
ProcessID = GetCurrentProcessId()
If Hide Then
retval = RegisterServiceProcess(ProcessID, RSP_SIMPLE_SERVICE)
Else
retval = RegisterServiceProcess(ProcessID, RSP_UNREGISTER_SERVICE)
End If
End Sub
Private Sub Form_Load()
HideApp (True)
End Sub
--------------------------------------------------------------------------------
معرفة عدد الكلمات في النص
Public Function GetWordCount(ByVal Text As String) As Long
Text = Trim(Replace(Text, "-" & vbNewLine, ""))
'Replace new lines with a single space
Text = Trim(Replace(Text, vbNewLine, " "))
'Collapse multiple spaces into one single space
Do While Text Like "* *"
Text = Replace(Text, " ", " ")
Loop
'Split the string and return counted words
GetWordCount = 1 + UBound(Split(Text, " "))
End Function
وتستخدم
lLineCount = GetWordCount(Text1.Text)
--------------------------------------------------------------------------------
عرض فورم داخل فورم
أضف نموذجين Form1 , Form2
Private Declare Function SetParent Lib "user32" _
(ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Sub Form_Load()
SetParent Form1.hwnd, Form2.hwnd
Form2.Show
End Sub
--------------------------------------------------------------------------------
النسخ من و الى الحافظه
من التكست
Clipboard.Clear
Clipboard.SetText txtBox.Text, vbCFText
الى التكست
txtBox.SelText = Clipboard.GetText
txtBox.Text = Clipboard.GetText
--------------------------------------------------------------------------------
لإضهار الوقت والتاريخ
Private Sub Form_Load()
Label1.Caption = Time 'الوقت
Label2.Caption = Date 'التاريخ
End Sub
--------------------------------------------------------------------------------
لمسح ما يتواجد في تكست
Private Sub Form_Load()
Text1.Text = ""
End Sub
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
لإستبدال نص بأخر
ندرج Text4
ثم نعدل على text 1 ب
Multiline=true
Scrollbars=2-vertical
الاكواد
Dim StartPoint As Long
Private Sub Command1_Click()
Dim Position As Long
StartPoint = 1
Position = InStr(StartPoint, Text1.Text, Text2.Text)
If Position > 0 Then
Command2.Enabled = True
StartPoint = Position + 1
Text1.SelStart = Position - 1
Text1.SelLength = Len(Text2.Text)
Text1.SetFocus
Else
Command2.Enabled = False
MsgBox "انتهت عملية البحث الأن ولم يتم العثور عن المطلوب", , " بحث"
End If
End Sub
Private Sub Command2_Click()
Dim Position As Long
Position = InStr(StartPoint, Text1.Text, Text2.Text)
If Position > 0 Then
StartPoint = Position + 1
Text1.SelStart = Position - 1
Text1.SelLength = Len(Text2.Text)
Text1.SetFocus
Else
Command2.Enabled = False
MsgBox "انتهت عملية البحث الأن ولم يتم العثور عن المطلوب", , " بحث"
End If
End Sub
Private Sub Command3_Click()
Text1.Text = Replace(Text1.Text, Text3.Text, Text4.Text)
End Sub
Private Sub Form_Load()
End Sub
--------------------------------------------------------------------------------
نسخ و تغيير اسم ملف
FileCopy "C:\MyFile.EXT" As "C:\MyFile2.EXT"
--------------------------------------------------------------------------------
حذف ملف
Kill "D:\MyFile.EXT"
--------------------------------------------------------------------------------
حذف مجموعة من الملفات
Kill "*.TMP"
--------------------------------------------------------------------------------
تحميل محتويات ملف نصي في text
Open "c:\windows\desktop\books.txt" For Input As #1
Text1.Text = Input(LOF(1), 1)
Close #1
--------------------------------------------------------------------------------
إنشاء مجلد جديد
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
Private Declare Function CreateDirectory Lib "kernel32.dll" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Private Sub Command1_Click()
Dim attr As SECURITY_ATTRIBUTES ' security attributes structure
Dim rval As Long
' Set security attributes
attr.nLength = Len(attr) 'size of the structure
attr.lpSecurityDescriptor = 0 'normal level of security
attr.bInheritHandle = 1 'default setting
' Create directory.
rval = CreateDirectory(Text1.Text, attr)
End Sub
Private Sub Form_Load()
Text1.Text = "c:\Abdu"
Command1.Caption = "New Directory"
End Sub
--------------------------------------------------------------------------------
إزالة اسم البرنامج من قائمة المهام الموجودة في ويندوز
Ctrl + ALt + Delete
Private Sub Form_Load()
App.TaskVisible = False
End Sub
--------------------------------------------------------------------------------
لنقل ملف من مسار إلى مسار آخر
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
Private Sub Command1_Click()
MoveFile "c:\Windows\Desktop\a.txt", "c:\a.txt"
End Sub
--------------------------------------------------------------------------------
وضع محتويات ملف في ليست
Private Sub Command1_Click()
Dim StringHold As String
Open "C:\test.txt" For Input As #1
List1.Clear
While Not EOF(1)
Input #1, StringHold
List1.AddItem StringHold
Wend
Close #1
End Sub
--------------------------------------------------------------------------------
معرفة اذا تم تغيير محتويات textbox
Private bChanged As Boolean
Private Sub Text1_Change()
bChanged = True
End SubPrivate
Sub Form_Unload(Cancel As Boolean)
If bChanged Then
If Msgbox("Save Changes?", vbYesNo, "Save") = vbYes Then
'Save Changes Here.
End If
End If
End Sub
--------------------------------------------------------------------------------
انشاء مجلد جديد
Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Sub Command1_Click()
Dim Security As SECURITY_ATTRIBUTES
Ret& = CreateDirectory("C:\Directory", Security)
If Ret& = 0 Then MsgBox "Error : Couldn't create directory !", vbCritical + vbOKOnly
End Sub
--------------------------------------------------------------------------------
انشاء مسار
Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long
Private Sub Form_Load()
SHCreateDirectoryEx Me.hwnd, "c:\test\dir\hello\something\apiguide\", ByVal 0&
End Sub
--------------------------------------------------------------------------------
نسخ ملف
FileCopy "C:\WINDOWS\Temp\mitanya.swf", "c:\mitanya.swf"
طبع الصورة
Printer.Print Text1.Text
فتح اي ملف
Shell ""
هذا الكود يمكنك من عمل ذلك ( كلمة السر هي فلسطين )
[a = InputBox("إدخل الرقم السري", "الرقم السري")
If a = "فلسطين" Then '
MsgBox "كلمة السر صحيحة"
Else
MsgBox "كلمة السر خاطئة"
End
لتغيير لون الخط في التكست بوكس ما عليك إلا كتابة الكود
Text1.ForeColor = Color
يقوم بتحويل شكل التكست واليبل الى 3d
*كود برمجي*
--------------------------------------------------------------------------------
'Set form's AutoRedraw property toTrue
Sub PaintControl3D(frm As Form, Ctl As Control)
' This Sub draws lines around controls to make them 3d
' darkgrey, upper - horizontal
frm.Line (Ctl.Left, Ctl.Top - 15)-(Ctl.Left + _
Ctl.Width, Ctl.Top - 15), &H808080, BF
' darkgrey, left - vertical
frm.Line (Ctl.Left - 15, Ctl.Top)-(Ctl.Left - 15, _
Ctl.Top + Ctl.Height), &H808080, BF
' white, right - vertical
frm.Line (Ctl.Left + Ctl.Width, Ctl.Top)- _
(Ctl.Left + Ctl.Width, Ctl.Top + Ctl.Height), &HFFFFFF, BF
' white, lower - horizontal
frm.Line (Ctl.Left, Ctl.Top + Ctl.Height)- _
(Ctl.Left + Ctl.Width, Ctl.Top + Ctl.Height), &HFFFFFF, BF
End Sub
Sub PaintForm3D(frm As Form)
' This Sub draws lines around the Form to make it 3d
' white, upper - horizontal
frm.Line (0, 0)-(frm.ScaleWidth, 0), &HFFFFFF, BF
' white, left - vertical
frm.Line (0, 0)-(0, frm.ScaleHeight), &HFFFFFF, BF
' darkgrey, right - vertical
frm.Line (frm.ScaleWidth - 15, 0)-(frm.ScaleWidth - 15, _
frm.Height), &H808080, BF
' darkgrey, lower - horizontal
frm.Line (0, frm.ScaleHeight - 15)-(frm.ScaleWidth, _
frm.ScaleHeight - 15), &H808080, BF
End Sub
'DEMO USAGE
'Add 1 label and 1 textbox
Private Sub Form_Load()
Me.AutoRedraw = True
PaintForm3D Me
PaintControl3D Me, Label1 'Label1 is name of label
PaintControl3D Me, Text1 'Text1 is name of textbox
End Sub
ملاحظة في البداية لبد من انشاء تكست وليبل
كود لوضع مقطع الفيديو في بكتشر
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
MM.HWNDDISPLAY=PICTURE1.HWND
End Sub
هذا الكود يمكنك من قلب الصور عمودياً أو افقيا او نسخها
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
'الوضع الطبيعي النسخ
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.Width, Picture1.Height, 0, 0, _
Picture1.Width, Picture1.Height, vbSrcCopy
End Sub
Private Sub Command2_Click()
'الوضع الافقي
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.Width, Picture1.Height, Picture1.Width, _
0, -Picture1.Width, Picture1.Height, vbSrcCopy
End Sub
Private Sub Command3_Click()
'الوضع العمودي
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.Width, Picture1.Height, 0, Picture1.Height, _
Picture1.Width, -Picture1.Height, vbSrcCopy
End Sub
Private Sub Command4_Click()
'لقلب الصورة
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.Width, Picture1.Height, Picture1.Width, _
Picture1.Height, -Picture1.Width, -Picture1.Height, vbSrcCopy
End Sub
تحويل اي حرف إلى حرف ASCII
*كود برمجي*
--------------------------------------------------------------------------------
Dim temp as String
temp=asc(text1.text)
MsgBox temp
--------------------------------------------------
نسخ خلفية
Private Declare Function PaintDesktop Lib "user32" _
(ByVal hdc As Long) As Long
'انسخ هذ الكودالى حدث النقر في زر الامر
Private Sub Command1_Click()
PaintDesktop Form1.hdc
End Sub
--------------------------------------------------
استعراض صورة
On Error Resume Next
OpenFileDialog1.Filter = "Png File|*.png|Gif File|*.gif|Jpg File|*.jpg|Bmp File|*.bmp|All File|*.*"
OpenFileDialog1.Title = "استعراض صورة"
OpenFileDialog1.ShowDialog()
PictureBox1.Load(OpenFileDialog1.FileName)
استعراض فيديو
OpenFileDialog1.Showdialog
AxWindowsMediaPlayer1.URL = OpenFileDialog1.FileName
كود اللون
'display color dialog
ColorDialog1.ShowDialog()
'set the form's background color
Me.BackColor = ColorDialog1.Color
كود الخروج
End
الطريق لصنع برنامج الالوان
اولا اضافة ادة ColorDialog1
تانيا اضافة (2) Button
ثالثاا اضافة Label1
انتها الشرح
textBox1.text="اكتب هنا ما تريد"
الجمع
TextBox3.Text = Val(TextBox1.Text) + Val(TextBox2.Text)
الطرح
TextBox3.Text = Val(TextBox1.Text) - Val(TextBox2.Text)
القسمة
Text3Box.Text = Val(TextBox1.Text) / Val(TextBox2.Text)
الضرب
TextBox3.Text = Val(TextBox1.Text) * Val(TextBox2.Text)
اكواد المتصفح
للذهاب الى الموقع :
WebBrowser1.Navigate(TextBox1.Text)
للرجوع للصفحة السابقة :
WebBrowser1.GoBack()
للتقدم الى الصفحة التي رجعت عنها :
WebBrowser1.GoForward()
تحديث الصفحة :
WebBrowser1.Refresh()
حفظ الصورة
Dim xsave As New SaveFileDialog
xsave.Filter = "BMP Picture--*.bmp--PNG Picture--*.png--JPEG Picture--*.jpg"
xsave.title = "حفظ صورة"
xsave.showDialog
If xsave.FileName = nothing Then Exit Sub
PictureBox1.Image.Save(xsave.FileName)
كود لتحويل ألوان الصور إلى الرمادي
أضف زر كوماند ومربع صورة واكتب في الكوماند الكود التالي
كود:
Picture1.ScaleMode = vbPixels
x = Picture1.ScaleWidth
y = Picture1.ScaleHeight
For i = 0 To y - 1
For j = 0 To x - 1
pixel = Picture1.Point(j, i)
red = pixel Mod 256
green = ((pixel And &HFF00) / 256) Mod 256
blue = (pixel And &HFF0000) / 65536
g = ((red * 30) + (green * 60) + (blue * 20)) / 100
Picture1.PSet (j, i), RGB(g, g, g)
Next
Next
Picture1.ScaleMode = vbTwips
هذا الكود يحول الحروف الإنجليزية لإحرف كبيرة
كود:
Private Sub Text1_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr$(KeyAscii)))
End Sub
تغيير الصورة من ملونة الى متدرجة باللون الرمادي
Private Sub Command1_Click()
Picture1.ScaleMode = vbPixels
x = Picture1.ScaleWidth
y = Picture1.ScaleHeight
For i = 0 To y - 1
For j = 0 To x - 1
pixel = Picture1.Point(j, i(
red = pixel Mod 256
green = ((pixel And &HFF00) / 256) Mod 256
blue = (pixel And &HFF0000) / 65536
g = ((red * 30) + (green * 60) + (blue * 20)) /
100
Picture1.PSet (j, i), RGB(g, g, g(
Next
Next
Dim SecForm As New Form2
SecForm.ShowDialog()
هذا الكود يقوم بفتح النموذج الثاني عند النقر
Dim ThirdForm As New Form3
ThirdForm.ShowDialog()
هذا الكود يقوم بفتح النموذج الثالث عند النقر
----------------------------------
المصدر :- انوار للتعليم
http://mnef.7olm.org/t2-topic
